home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / unix_fault.t < prev    next >
Text File  |  1989-06-30  |  7KB  |  204 lines
  1. (herald unix_fault (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; To do:
  27. ;;;     exception frame handle
  28. ;;;     interrupt frame handle
  29. ;;;     interrupt-queue
  30. ;;;     heap-guard-handler
  31. ;;;     stack-guard-handler
  32.  
  33. (define-constant foreign-fault-frame? alt-bit-set?)
  34.  
  35. (define-handler fault-frame
  36.   (object nil
  37.       ((frame-previous self) 
  38.        (make-pointer self (bytev-length self)))
  39.       ((print-type-string self) "Fault-frame")))
  40.  
  41. (define-handler interrupt-frame
  42.   (object nil
  43.       ((frame-previous self) 
  44.        (make-pointer self (fx+ *argument-registers* 8)))
  45.       ((crawl-exhibit self) (crawl-exhibit-interrupt-frame self))
  46.       ((print-type-string self) "Interrupt-frame")))
  47.                                                                   
  48. (define (print-register frame name index)
  49.   (let ((out (crawl-output)))
  50.     (format out " ~s = " name)
  51.     (print-one-line (extend-elt frame index) out)
  52.     (newline out)))
  53.  
  54.  
  55. (define (make-error-handler msg)
  56.   (lambda ()
  57.     (error msg)))
  58.  
  59. (define (make-NC-error-handler msg)
  60.   (lambda ()
  61.     (non-continuable-error msg)))
  62.  
  63.  
  64. ;;; Unix signal handler
  65.  
  66. (define-operation (get-handler obj type))
  67.  
  68. ;++ this should be doing arg checking
  69.  
  70. (define signal-handler
  71.   (let ((handler-vector (vector-fill
  72.                          (make-vector (fx+ number-of-signals 1))
  73.                          'default)))
  74.     (object (lambda (ssp signal)
  75.           (enable-signals)
  76.           (let ((returned? nil))
  77.         (unwind-protect
  78.           (receive vals ((vref handler-vector signal))
  79.             (set returned? t)
  80.             (apply return vals))
  81.           (if (not returned?)
  82.               (reset-ssp ssp)))))
  83.       ((setter self)
  84.        (lambda (signal class handler)
  85.          (set (vref handler-vector signal) handler)
  86.          (if (fx= (set-signal signal class) -1)
  87.              (error "call to sigvec failed for signal ~d" signal))))
  88.        ((get-handler self type)
  89.         (vref handler-vector type)))))
  90.  
  91. (define set-signal
  92.   (let ((sigvec-struct (make-bytev 12))
  93.         (return-struct (make-bytev 12)))
  94.     (set (mref-integer sigvec-struct 8) 0)
  95.     (set (mref-integer sigvec-struct 4) %%SIGINT)   ; sigint disabled    
  96.     (lambda (type class)
  97.       (set (mref-integer sigvec-struct 0)
  98.            (xcase class
  99.              ((A) (system-global slink/interrupt-handler))
  100.              ((E) (system-global slink/interrupt-handler))
  101.              ((D) 0)
  102.              ((I) 1)))
  103.       (unix-sigvec type sigvec-struct return-struct))))
  104.  
  105. (define-foreign unix-sigvec ("sigvec" (in rep/integer)
  106.                                     (in rep/extend)
  107.                                     (in rep/extend))
  108.                 rep/integer)
  109.  
  110. (define-integrable (set-mask-bit mask n)
  111.   (fixnum-logior mask (fixnum-ashl 1 (fx- n 1))))
  112.  
  113. (define-integrable (clear-mask-bit mask n)
  114.   (fixnum-logand (fixnum-lognot (fixnum-ashl 1 (fx- n 1))) mask))
  115.  
  116. (define (disable-signal sig)
  117.   (unix-sigblock (set-mask-bit 0 sig)))
  118.  
  119. (define (enable-signals)
  120.   (unix-sigsetmask 0))                                     
  121.  
  122. (define (enable-signal sig)
  123.   (unix-sigsetmask (clear-mask-bit (unix-sigblock 0) sig)))
  124.  
  125. (define-foreign unix-sigsetmask ("sigsetmask" (in rep/integer))
  126.                 rep/integer)
  127.  
  128. (define-foreign unix-sigblock ("sigblock" (in rep/integer))
  129.                 rep/integer)
  130.  
  131. ;;; Standard signal handlers.
  132.  
  133. (define (interrupt-handler)
  134.   (breakpoint "Interrupt"))
  135.  
  136.  
  137. (define (sigint-handler)
  138.   (let ((stamp (gc-stamp)))
  139.     (breakpoint "Interrupt")
  140.     (if (fxn= (gc-stamp) stamp)
  141.     (non-continuable-error "Interrupted code can't continue due to GC"))))
  142.  
  143.  
  144. (define (sigquit-handler)
  145.   (let ((stamp (gc-stamp)))
  146.     (z-breakpoint)
  147.     (if (fxn= (gc-stamp) stamp)
  148.     (non-continuable-error "Interrupted code can't continue due to GC"))))
  149.  
  150.  
  151. ;;; Initialize the condition system.  This procedure must be called
  152. ;;; to enable the T error system.  It should be called as soon as
  153. ;;; possible during the startup sequence.
  154.  
  155. (define (initialize-condition-system)
  156.   (do ((l *signals* (cdr l)))
  157.       ((null? l)
  158.        (set (signal-handler %%SIGINT 'A)  sigint-handler)
  159.        (set (signal-handler %%SIGQUIT 'A) sigquit-handler))
  160.     (destructure (((type class handler msg) (car l)))
  161.       (set (signal-handler type class)
  162.            (case handler
  163.                  ((error)
  164.                   (make-error-handler msg))
  165.                  ((non-continuable)
  166.                   (make-NC-error-handler msg))
  167.                  ((default) 'default)
  168.                  ((ignore)  'ignore)
  169.                  (else handler))))))
  170.  
  171. ;;; Exit from T, optionally setting the return code
  172.  
  173. (lset exit-agenda (make-agenda 'exit-agenda))
  174.  
  175. (lset exit
  176.       (lambda arg
  177.     (exit-agenda)
  178.     (unix-exit (if (null? arg) 0 (car arg)))))
  179.  
  180. (define-foreign unix-exit ("exit" (in rep/integer))
  181.                 rep/undefined)
  182.  
  183. ;;; Local OS error handling
  184.  
  185. (define-integrable (check-status status)
  186.   (if (fx< 0 status) (local-os-error status)))
  187.  
  188. (define (local-os-error STATUS)
  189.   (error "~&** VM Unix error - ~a" (local-os-error-message status)))
  190.  
  191. (define (local-os-error-message status)
  192.   (ignore status)
  193.   (let ((msg (get-string-buffer-of-size 128)))
  194.     (set (string-length msg) 128)
  195.     (unix-error msg 128)
  196.     (set (string-length msg) (string-posq #\null msg))
  197.     (let ((msg1 (copy-string msg)))
  198.       (release-string-buffer msg)
  199.       msg1)))
  200.  
  201. (define-foreign unix-error ("get_unix_error_msg" (in rep/string)
  202.                                                (in rep/integer))
  203.                 rep/undefined)
  204.